home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / print / ppabsyn.sml next >
Encoding:
Text File  |  1993-01-27  |  20.6 KB  |  608 lines

  1. (* Copyright 1992 by AT&T Bell Laboratories *)
  2. (* absyn/ppabsyn.sml *)
  3.  
  4. signature PPABSYN =
  5. sig
  6.   val ppPat    : Modules.env -> PrettyPrint.ppstream -> Absyn.pat * int -> unit
  7.   val ppExp    : Modules.env * Source.inputSource option -> PrettyPrint.ppstream
  8.                  -> Absyn.exp * int    -> unit
  9.   val ppRule   : Modules.env * Source.inputSource option -> PrettyPrint.ppstream
  10.                  -> Absyn.rule * int   -> unit
  11.   val ppVB     : Modules.env * Source.inputSource option -> PrettyPrint.ppstream
  12.                  -> Absyn.vb * int     -> unit
  13.   val ppRVB    : Modules.env * Source.inputSource option -> PrettyPrint.ppstream
  14.                  -> Absyn.rvb * int    -> unit
  15.   val ppDec    : Modules.env * Source.inputSource option -> PrettyPrint.ppstream
  16.                  -> Absyn.dec * int    -> unit
  17.   val ppStrexp : Modules.env * Source.inputSource option -> PrettyPrint.ppstream
  18.                  -> Absyn.strexp * int -> unit
  19. end
  20.  
  21. structure PPAbsyn: PPABSYN = struct
  22.  
  23. open Absyn Access ErrorMsg Tuples
  24. open Fixity Variables Types Modules
  25. open PrettyPrint PPUtil
  26. open PPType PPBasics
  27.  
  28. val lineprint = ref false
  29.  
  30. fun C f x y = f y x
  31.  
  32. fun prpos(ppstrm: PrettyPrint.ppstream,source: Source.inputSource,charpos: int) =
  33.     if (!lineprint) then
  34.       let val (file:string,line:int,pos:int) = Source.filepos source charpos
  35.        in add_string ppstrm (makestring line);
  36.       add_string ppstrm ".";
  37.       add_string ppstrm (makestring pos)
  38.       end
  39.     else add_string ppstrm (makestring charpos)
  40.  
  41.  
  42. fun nl_indent ppstrm i = add_break ppstrm (127,i)
  43.     (* !!! 127 should be !line_width+1 *)
  44.  
  45. fun checkpat (n,nil) = true
  46.   | checkpat (n, (sym,_)::fields) = 
  47.     Symbol.eq(sym, numlabel n) andalso checkpat(n+1,fields)
  48.  
  49. fun checkexp (n,nil) = true
  50.   | checkexp (n, (LABEL{name=sym,...},_)::fields) = 
  51.     Symbol.eq(sym, numlabel n) andalso checkexp(n+1,fields)
  52.  
  53. fun isTUPLEpat (RECORDpat{fields=[_],...}) = false
  54.   | isTUPLEpat (RECORDpat{flex=false,fields,...}) = checkpat(1,fields)
  55.   | isTUPLEpat _ = false
  56.     
  57. fun isTUPLEexp (RECORDexp [_]) = false
  58.   | isTUPLEexp (RECORDexp fields) = checkexp(1,fields)
  59.   | isTUPLEexp (MARKexp(a,_,_)) = isTUPLEexp a
  60.   | isTUPLEexp _ = false
  61.  
  62. fun lookFIX (env,sym) =
  63.     ModuleUtil.lookFIX (env,Symbol.fixSymbol(Symbol.name sym))
  64.  
  65. fun prunemark (MARKexp(a,_,_)) = prunemark a
  66.   | prunemark x = x
  67.  
  68. fun ppvlist ppstrm (header,separator,pr_item,items) =
  69.     case items
  70.       of nil => ()
  71.        | first::rest =>
  72.        (add_string ppstrm header;
  73.         pr_item ppstrm first;
  74.         app (fn x => (add_newline ppstrm;
  75.               add_string ppstrm separator;
  76.               pr_item ppstrm x))
  77.          rest)
  78.  
  79. fun ppPat env ppstrm =
  80.     let val ppsay = add_string ppstrm
  81.     fun ppPat' (_,0) = ppsay "<pat>"
  82.       | ppPat' (VARpat v,_) = ppVar ppstrm v
  83.       | ppPat' (WILDpat,_) = ppsay "_"
  84.       | ppPat' (INTpat i,_) = ppsay (makestring i)
  85.       | ppPat' (REALpat r,_) = ppsay r
  86.       | ppPat' (STRINGpat s,_) = pp_mlstr ppstrm s
  87.       | ppPat' (LAYEREDpat (v,p),d) =
  88.           (begin_block ppstrm CONSISTENT 0;
  89.            ppPat'(v,d); ppsay " as "; ppPat'(p,d-1);
  90.            end_block ppstrm)
  91.             (* Handle 0 length case specially to avoid {,...}: *)
  92.       | ppPat' (RECORDpat{fields=[],flex,...},_) =
  93.           if flex then ppsay "{...}"
  94.           else ppsay "()"
  95.       | ppPat' (r as RECORDpat{fields,flex,...},d) =
  96.           if isTUPLEpat r
  97.           then ppClosedSequence ppstrm
  98.              {front=(C add_string "("),
  99.               sep=(fn ppstrm => (add_string ppstrm ",";
  100.                      add_break ppstrm (0,0))),
  101.               back=(C add_string ")"),
  102.               pr=(fn _ => fn (sym,pat) => ppPat'(pat,d-1)),
  103.               style=INCONSISTENT}
  104.              fields
  105.           else ppClosedSequence ppstrm
  106.              {front=(C add_string "{"),
  107.               sep=(fn ppstrm => (add_string ppstrm ",";
  108.                      add_break ppstrm (0,0))),
  109.               back=(fn ppstrm => if flex then add_string ppstrm ",...}"
  110.                          else add_string ppstrm "}"),
  111.               pr=(fn ppstrm => fn (sym,pat) =>
  112.               (ppSym ppstrm sym; add_string ppstrm "=";
  113.                ppPat'(pat,d-1))),
  114.               style=INCONSISTENT}
  115.              fields
  116.       | ppPat' (VECTORpat(nil,_), d) = ppsay "#[]"
  117.       | ppPat' (VECTORpat(pats,_), d) = 
  118.           let fun pr _ pat = ppPat'(pat, d-1)
  119.            in ppClosedSequence ppstrm
  120.             {front=(C add_string "#["),
  121.              sep=(fn ppstrm => (add_string ppstrm ",";
  122.                     add_break ppstrm (0,0))),
  123.              back=(C add_string "]"),
  124.              pr=pr,
  125.              style=INCONSISTENT}
  126.             pats
  127.           end
  128.       | ppPat' (CONpat(e,_),_) = ppDcon ppstrm e
  129.       | ppPat' (p as APPpat _, d) =
  130.           let val noparen = INfix(0,0)
  131.            in ppDconPat (env,ppstrm) (p,noparen,noparen,d)
  132.           end
  133.       | ppPat' (CONSTRAINTpat (p,t),d) =
  134.          (begin_block ppstrm INCONSISTENT 0;
  135.           ppPat'(p,d-1); ppsay " :";
  136.           add_break ppstrm (1,2);
  137.           ppType env ppstrm t;
  138.           end_block ppstrm)
  139.      in ppPat'
  140.     end
  141.  
  142. and ppDconPat(env,ppstrm) = 
  143.     let val ppsay = add_string ppstrm
  144.     fun ppDconPat'(_,_,_,0) = ppsay "<pat>"
  145.       | ppDconPat'(CONpat(DATACON{name,...},_),l:fixity,r:fixity,_) =
  146.           ppSym ppstrm name
  147.       | ppDconPat'(CONSTRAINTpat(p,t),l,r,d) =
  148.          (begin_block ppstrm INCONSISTENT 0;
  149.           ppsay "("; ppPat env ppstrm (p,d-1); ppsay " :";
  150.           add_break ppstrm (1,2);
  151.           ppType env ppstrm t; ppsay ")";
  152.           end_block ppstrm)
  153.       | ppDconPat'(LAYEREDpat(v,p),l,r,d) =
  154.          (begin_block ppstrm INCONSISTENT 0;
  155.           ppsay "("; ppPat env ppstrm (v,d); add_break ppstrm (1,2);
  156.           ppsay " as "; ppPat env ppstrm (p,d-1); ppsay ")";
  157.           end_block ppstrm)
  158.       | ppDconPat'(APPpat(DATACON{name,...},_,p),l,r,d) =
  159.           let val dname = Symbol.name name
  160.           val fixity = lookFIX(env,name)
  161.           fun prdcon() =
  162.               case (fixity,isTUPLEpat p,p)
  163.             of (INfix _,true,RECORDpat{fields=[(_,pl),(_,pr)],...}) =>
  164.                    (ppDconPat'(pl,NONfix,fixity,d-1);
  165.                     ppsay " "; ppsay dname; ppsay " ";
  166.                     ppDconPat'(pr,fixity,NONfix,d-1))
  167.               | _ => (ppsay dname; ppsay " ";
  168.                   ppDconPat'(p,NONfix,NONfix,d-1))
  169.           in  case (l,r,fixity)
  170.             of (NONfix,NONfix,_) => (ppsay "("; prdcon(); ppsay ")")
  171.              | (INfix _,INfix _,_) => prdcon()
  172.              | (_,_,NONfix) => prdcon()
  173.              | (INfix(_,p1),_,INfix(p2,_)) =>
  174.              if p1 >= p2
  175.              then (ppsay "("; prdcon(); ppsay ")")
  176.              else prdcon()
  177.              | (_,INfix(p1,_),INfix(_,p2)) =>
  178.              if p1 > p2
  179.              then (ppsay "("; prdcon(); ppsay ")")
  180.              else prdcon()
  181.           end
  182.       | ppDconPat' (p,_,_,d) = ppPat env ppstrm (p,d)
  183.      in ppDconPat'
  184.     end
  185.  
  186. fun trim [x] = nil | trim (a::b) = a::trim b
  187.  
  188. fun ppExp (context as (env,source_opt)) ppstrm =
  189.     let val ppsay = add_string ppstrm
  190.     fun ppExp'(_,0) = ppsay "<exp>"
  191.       | ppExp'(VARexp(ref var,_),_) = ppVar ppstrm var
  192.       | ppExp'(CONexp(con,_),_) = ppDcon ppstrm con
  193.       | ppExp'(INTexp i,_) = ppsay(makestring i)
  194.       | ppExp'(REALexp r,_) = ppsay r
  195.       | ppExp'(STRINGexp s,_) = pp_mlstr ppstrm s
  196.       | ppExp'(r as RECORDexp fields,d) =
  197.           if isTUPLEexp r
  198.           then ppClosedSequence ppstrm
  199.              {front=(C add_string "("),
  200.               sep=(fn ppstrm => (add_string ppstrm ",";
  201.                      add_break ppstrm (0,0))),
  202.               back=(C add_string ")"),
  203.               pr=(fn _ => fn (_,exp) => ppExp'(exp,d-1)),
  204.               style=INCONSISTENT}
  205.              fields
  206.           else ppClosedSequence ppstrm
  207.              {front=(C add_string "{"),
  208.               sep=(fn ppstrm => (add_string ppstrm ",";
  209.                      add_break ppstrm (0,0))),
  210.               back=(C add_string "}"),
  211.               pr=(fn ppstrm => fn (LABEL{name,...},exp) =>
  212.               (ppSym ppstrm name; ppsay "=";
  213.                ppExp'(exp,d))),
  214.               style=INCONSISTENT}
  215.              fields
  216.       | ppExp'(VECTORexp nil, d) = ppsay "#[]"
  217.       | ppExp'(VECTORexp exps, d) =
  218.           let fun pr _ exp = ppExp'(exp,d-1)
  219.           in  ppClosedSequence ppstrm
  220.             {front=(C add_string "#["),
  221.              sep=(fn ppstrm => (add_string ppstrm ",";
  222.                     add_break ppstrm (1,0))),
  223.              back=(C add_string "]"),
  224.              pr=pr,
  225.              style=INCONSISTENT}
  226.             exps
  227.           end
  228.       | ppExp'(SEQexp exps,d) =
  229.           ppClosedSequence ppstrm
  230.             {front=(C add_string "("),
  231.          sep=(fn ppstrm => (add_string ppstrm ";";
  232.                     add_break ppstrm (1,0))),
  233.          back=(C add_string ")"),
  234.          pr=(fn _ => fn exp => ppExp'(exp,d-1)),
  235.          style=INCONSISTENT}
  236.         exps
  237.       | ppExp'(e as APPexp _,d) =
  238.           let val noparen = INfix(0,0)
  239.           in  ppAppExp (e,noparen,noparen,d)
  240.           end
  241.       | ppExp'(CONSTRAINTexp(e, t),d) =
  242.          (begin_block ppstrm INCONSISTENT 0;
  243.           ppsay "("; ppExp'(e,d); ppsay ":";
  244.           add_break ppstrm (1,2);
  245.           ppType env ppstrm t; ppsay ")";
  246.           end_block ppstrm)
  247.       | ppExp'(HANDLEexp(exp, HANDLER(FNexp(rules,_))),d) =
  248.          (begin_block ppstrm CONSISTENT 0;
  249.           ppExp'(exp,d-1); add_newline ppstrm; ppsay "handle ";
  250.           nl_indent ppstrm 2;
  251.           ppvlist ppstrm ("  ","| ",
  252.           (fn ppstrm => fn r => ppRule context ppstrm (r,d-1)), rules);
  253.           end_block ppstrm)
  254.       | ppExp'(HANDLEexp(exp, HANDLER _),d) =
  255.           impossible "ppExp':impossible handler"
  256.       | ppExp'(RAISEexp(exp,_),d) = 
  257.           (begin_block ppstrm CONSISTENT 0;
  258.            ppsay "raise "; ppExp'(exp,d-1);
  259.            end_block ppstrm)
  260.       | ppExp'(LETexp(dec, exp),d) =
  261.           (begin_block ppstrm CONSISTENT 0;
  262.            ppsay "let "; ppDec context ppstrm (dec,d-1); add_break ppstrm (1,0);
  263.            ppsay " in "; ppExp'(exp,d-1); add_break ppstrm (1,0);
  264.            ppsay "end";
  265.            end_block ppstrm)
  266.       | ppExp'(CASEexp(exp, rules),d) =
  267.           (begin_block ppstrm CONSISTENT 0;
  268.            ppsay "(case "; ppExp'(exp,d-1); nl_indent ppstrm 2;
  269.            ppvlist ppstrm ("of ","   | ",
  270.          (fn ppstrm => fn r => ppRule context ppstrm (r,d-1)), trim rules);
  271.            ppsay ")";
  272.            end_block ppstrm)
  273.       | ppExp'(FNexp(rules,_),d) =
  274.           (begin_block ppstrm CONSISTENT 0;
  275.            ppvlist ppstrm ("(fn ","  | ",
  276.                    (fn ppstrm => fn r =>
  277.                   ppRule context ppstrm (r,d-1)),
  278.                    trim rules);
  279.            ppsay ")";
  280.            end_block ppstrm)
  281.       | ppExp'(MARKexp (exp,s,e),d) =
  282.           (case source_opt
  283.         of SOME source =>
  284.                (ppsay "MARKexp(";
  285.             ppExp'(exp,d); ppsay ",";
  286.             prpos(ppstrm,source,s); ppsay ",";
  287.             prpos(ppstrm,source,e); ppsay ")")
  288.              | NONE => ppExp'(exp,d))
  289.  
  290.     and ppAppExp (_,_,_,0) = add_string ppstrm "<exp>"
  291.       | ppAppExp arg =
  292.         let val ppsay = add_string ppstrm
  293.         fun fixitypp(name,e,l,r,d) =
  294.             let val dname = formatQid name
  295.             val fixity = case name of [id] => lookFIX(env,id)
  296.                         | _ => NONfix
  297.             fun pr() =
  298.                 case (fixity,isTUPLEexp e,prunemark e)
  299.                   of (INfix _,true,RECORDexp[(_,pl),(_,pr)]) =>
  300.                     (begin_block ppstrm INCONSISTENT 2;
  301.                      ppAppExp (pl,NONfix,fixity,d-1);
  302.                      add_break ppstrm (1,0); ppsay dname;
  303.                      add_break ppstrm (1,0);
  304.                      ppAppExp (pr,fixity,NONfix,d-1);
  305.                      end_block ppstrm)
  306.                 | _ =>
  307.                     (begin_block ppstrm INCONSISTENT 2;
  308.                      ppsay dname; add_break ppstrm (1,0);
  309.                      ppAppExp (e,NONfix,NONfix,d-1);
  310.                      end_block ppstrm)
  311.             in  case (l,r,fixity)
  312.               of (NONfix,NONfix,_) => (ppsay "("; pr(); ppsay ")")
  313.                | (INfix _,INfix _,_) => pr()
  314.                | (_,_,NONfix) => pr()
  315.                | (INfix(_,p1),_,INfix(p2,_)) =>
  316.                 if p1 >= p2 then (ppsay "("; pr(); ppsay ")")
  317.                 else pr()
  318.                | (_,INfix(p1,_),INfix(_,p2)) =>
  319.                 if p1 > p2 then (ppsay "("; pr(); ppsay ")")
  320.                 else pr()
  321.             end
  322.         fun appPrint(_,_,_,0) = ppsay "#"
  323.           | appPrint(CONSTRAINTexp(e,t),l,r,d) =
  324.               (begin_block ppstrm INCONSISTENT 2;
  325.                ppsay "("; ppExp'(e,d-1);
  326.                ppsay " :"; add_break ppstrm (1,1);
  327.                ppType env ppstrm t; ppsay ")";
  328.                end_block ppstrm)
  329.           | appPrint(APPexp(CONexp(DATACON{name,...},_),e),l,r,d) =
  330.               fixitypp([name],e,l,r,d)
  331.           | appPrint(APPexp(VARexp(ref(VALvar{name,...}),_),e),l,r,d) =
  332.               fixitypp(name,e,l,r,d)
  333.           | appPrint(APPexp(VARexp(ref(OVLDvar{name,...}),_),e),l,r,d) =
  334.               fixitypp([name],e,l,r,d)
  335.           | appPrint(APPexp(app as APPexp _,rand),NONfix,NONfix,d) =
  336.               let val yesparen = INfix(0,100000000) (* a hack *)
  337.                in begin_block ppstrm INCONSISTENT 2;
  338.               ppsay "("; appPrint(app,yesparen,NONfix,d-1);
  339.               add_break ppstrm (1,2);
  340.               appPrint(rand,NONfix,NONfix,d-1); ppsay ")";
  341.               end_block ppstrm
  342.               end
  343.           | appPrint(APPexp(app as APPexp _,rand),l,r,d) =
  344.               let val yesparen = INfix(0,100000000) (* a hack *)
  345.                in begin_block ppstrm INCONSISTENT 2;
  346.               appPrint(app,yesparen,NONfix,d-1);
  347.               add_break ppstrm (1,2);
  348.               appPrint(rand,NONfix,NONfix,d-1);
  349.               end_block ppstrm
  350.               end
  351.           | appPrint(APPexp(rator,rand),_,_,d) =
  352.               (begin_block ppstrm INCONSISTENT 2;
  353.                ppExp'(rator,d-1);
  354.                add_break ppstrm (1,2); ppExp'(rand,d-1);
  355.                end_block ppstrm)
  356.           | appPrint(MARKexp(exp,s,e),l,r,d) =
  357.               (case source_opt
  358.             of SOME source =>
  359.                (ppsay "MARKexp(";
  360.                 appPrint(exp,l,r,d); ppsay ",";
  361.                 prpos(ppstrm,source,s); ppsay ",";
  362.                 prpos(ppstrm,source,e); ppsay ")")
  363.              | NONE => appPrint(exp,l,r,d))
  364.           | appPrint (e,_,_,d) = ppExp'(e,d)
  365.          in appPrint arg
  366.         end
  367.      in ppExp'
  368.     end
  369.  
  370. and ppRule (context as (env,source_opt)) ppstrm (RULE(pat,exp),d) =
  371.     if d>0
  372.     then (begin_block ppstrm CONSISTENT 0;
  373.       ppPat env ppstrm (pat,d-1);
  374.       add_string ppstrm " =>"; add_break ppstrm (1,0);
  375.       ppExp context ppstrm (exp,d-1);
  376.       end_block ppstrm)
  377.     else add_string ppstrm "<rule>"
  378.  
  379. and ppVB (context as (env,source_opt)) ppstrm (VB{pat,exp,...},d) =
  380.     if d>0
  381.     then (begin_block ppstrm CONSISTENT 0;
  382.       ppPat env ppstrm (pat,d-1); add_string ppstrm " =";
  383.       add_break ppstrm (1,2); ppExp context ppstrm (exp,d-1);
  384.       end_block ppstrm)
  385.     else add_string ppstrm "<binding>"
  386.  
  387. and ppRVB context ppstrm (RVB{var,exp,...},d) = 
  388.     if d>0
  389.     then (begin_block ppstrm INCONSISTENT 0;
  390.       ppVar ppstrm var; add_string ppstrm " =";
  391.       add_break ppstrm (1,2); ppExp context ppstrm (exp,d-1);
  392.       end_block ppstrm)
  393.     else add_string ppstrm "<rec binding>"
  394.  
  395. and ppDec (context as (env,source_opt)) ppstrm =
  396.   let val ppsay = add_string ppstrm
  397.       fun ppDec'(_,0) = ppsay "<dec>"
  398.       | ppDec'(VALdec vbs,d) =
  399.       (begin_block ppstrm CONSISTENT 0;
  400.        ppvlist ppstrm ("val ","and ",
  401.          (fn ppstrm => fn vb => ppVB context ppstrm (vb,d-1)),vbs);
  402.        end_block ppstrm)
  403.       | ppDec'(VALRECdec rvbs,d) =
  404.       (begin_block ppstrm CONSISTENT 0;
  405.        ppvlist ppstrm ("val rec ","and ",
  406.          (fn ppstrm => fn rvb => ppRVB context ppstrm (rvb,d-1)),rvbs);
  407.        end_block ppstrm)
  408.       | ppDec'(TYPEdec tbs,d) =
  409.       (begin_block ppstrm CONSISTENT 0;
  410.        ppvlist ppstrm ("type "," and ",
  411.         (fn ppstrm =>
  412.          (fn (TB{tyc=DEFtyc{path=name::_, tyfun=TYFUN{arity,...},...},def}) =>
  413.          (case arity
  414.             of 0 => ()
  415.              | 1 => (ppsay "'a ")
  416.              | n => (ppTuple ppstrm add_string (typeFormals n); ppsay " ");
  417.           ppSym ppstrm name; ppsay " = "; ppType env ppstrm def)
  418.            | _ => impossible "ppabsyn.398")),
  419.          tbs);
  420.        end_block ppstrm)
  421.       | ppDec'(DATATYPEdec{datatycs,withtycs},d) =
  422.       (begin_block ppstrm CONSISTENT 0;
  423.        ppvlist ppstrm ("datatype ","and ",
  424.         (fn ppstrm =>
  425.          (fn GENtyc{path=name::_, arity, kind=ref(DATAtyc dcons),...} =>
  426.          (case arity
  427.             of 0 => ()
  428.              | 1 => (ppsay "'a ")
  429.              | n => (ppTuple ppstrm add_string (typeFormals n); ppsay " ");
  430.           ppSym ppstrm name; ppsay " = ";
  431.           ppSequence ppstrm
  432.             {sep=(fn ppstrm => (add_string ppstrm " |";
  433.                     add_break ppstrm (1,0))),
  434.              pr=(fn ppstrm => fn (DATACON{name,...}) => ppSym ppstrm name),
  435.              style=INCONSISTENT}
  436.             dcons)
  437.            | _ => impossible "ppabsyn.8")),
  438.          datatycs);
  439.        add_newline ppstrm;
  440.        ppvlist ppstrm ("withtype ","and ",
  441.         (fn ppstrm =>
  442.          (fn (TB{tyc=DEFtyc{path=name::_, tyfun=TYFUN{arity,...},...},def}) =>
  443.          (case arity
  444.             of 0 => ()
  445.              | 1 => (ppsay "'a ")
  446.              | n => (ppTuple ppstrm add_string (typeFormals n); ppsay " ");
  447.           ppSym ppstrm name; ppsay " = "; ppType env ppstrm def)
  448.            | _ => impossible "ppabsyn.398")),
  449.          withtycs);
  450.        end_block ppstrm)
  451.       | ppDec'(ABSTYPEdec _,d) = ppsay "abstype"
  452.       | ppDec'(EXCEPTIONdec ebs,d) =
  453.       (begin_block ppstrm CONSISTENT 0;
  454.        ppvlist ppstrm ("exception ","and ",
  455.         (fn ppstrm =>
  456.          (fn (EBgen{exn=DATACON{name,...},etype,...}) =>
  457.            (ppSym ppstrm name;
  458.             case etype
  459.               of NONE => ()
  460.                | SOME ty' =>
  461.               (ppsay " of "; ppType env ppstrm ty'))
  462.            | (EBdef{exn=DATACON{name,...},edef=DATACON{name=dname,...}}) =>
  463.            (ppSym ppstrm name; ppsay "="; ppSym ppstrm dname))),
  464.          ebs);
  465.        end_block ppstrm)
  466.       | ppDec'(STRdec sbs,d) =
  467.       (begin_block ppstrm CONSISTENT 0;
  468.        ppvlist ppstrm ("structure ","and ",
  469.         (fn ppstrm =>
  470.          (fn (STRB{strvar=STRvar{access,name,...},def,...}) =>
  471.          (ppSym ppstrm name; ppAccess ppstrm access; ppsay " = ";
  472.           add_break ppstrm (1,2); ppStrexp context ppstrm (def,d-1)))),
  473.          sbs);
  474.        end_block ppstrm)
  475.       | ppDec'(ABSdec sbs,d) =
  476.       (begin_block ppstrm CONSISTENT 0;
  477.        ppvlist ppstrm ("abstraction ","and ",
  478.         (fn ppstrm =>
  479.          (fn (STRB{strvar=STRvar{access,name,...},def,...}) =>
  480.          (ppSym ppstrm name; ppAccess ppstrm access; ppsay " = ";
  481.           add_break ppstrm (1,2); ppStrexp context ppstrm (def,d-1)))),
  482.          sbs);
  483.        end_block ppstrm)
  484.       | ppDec'(FCTdec fbs,d) =
  485.       (begin_block ppstrm CONSISTENT 0;
  486.        ppvlist ppstrm ("functor ","and ",
  487.         (fn ppstrm =>
  488.          (fn (FCTB{fctvar=FCTvar{access,name=fname,...},
  489.                def=FCTfct{param=STRvar{name=pname,...},def,...}}) =>
  490.            (ppSym ppstrm fname; ppAccess ppstrm access; ppsay " ("; 
  491.             ppSym ppstrm pname; ppsay ") = "; add_newline ppstrm;
  492.             ppStrexp context ppstrm (def,d-1))
  493.                | (FCTB{fctvar=FCTvar{access,name=fname,...},
  494.                def=VARfct{def=FCTvar{name=fname',...},...}}) =>
  495.            (ppSym ppstrm fname; ppAccess ppstrm access; ppsay " = "; 
  496.             ppSym ppstrm fname'))),
  497.          fbs);
  498.        end_block ppstrm)
  499.       | ppDec'(SIGdec sigvars,d) =
  500.       (begin_block ppstrm CONSISTENT 0;
  501.        ppSequence ppstrm
  502.          {sep=add_newline,
  503.           pr=(fn ppstrm => fn SIGvar{name,...} =>
  504.             (ppsay "signature "; ppSym ppstrm name)),
  505.           style=CONSISTENT}
  506.          sigvars;
  507.        end_block ppstrm)
  508.       | ppDec'(FSIGdec sigvars,d) =
  509.       (begin_block ppstrm CONSISTENT 0;
  510.        ppSequence ppstrm
  511.          {sep=add_newline,
  512.           pr=(fn ppstrm => fn FSIGvar{name,...} =>
  513.             (ppsay "funsig "; ppSym ppstrm name)),
  514.           style=CONSISTENT}
  515.          sigvars;
  516.        end_block ppstrm)
  517.       | ppDec'(LOCALdec(inner,outer),d) =
  518.       (begin_block ppstrm CONSISTENT 0;
  519.        ppsay "local"; nl_indent ppstrm 2;
  520.        ppDec'(inner,d-1); add_newline ppstrm;
  521.        ppsay "in ";
  522.        ppDec'(outer,d-1); add_newline ppstrm;
  523.        ppsay "end";
  524.        end_block ppstrm)
  525.       | ppDec'(SEQdec decs,d) =
  526.       (begin_block ppstrm CONSISTENT 0;
  527.        ppSequence ppstrm
  528.          {sep=add_newline,
  529.           pr=(fn ppstrm => fn dec => ppDec'(dec,d)),
  530.           style=CONSISTENT}
  531.          decs;
  532.        end_block ppstrm)
  533.       | ppDec'(FIXdec {fixity,ops},d) =
  534.       (begin_block ppstrm CONSISTENT 0;
  535.        case fixity
  536.          of NONfix => ppsay "nonfix "
  537.           | INfix (i,_) => 
  538.             (if i mod 2 = 0 then 
  539.                ppsay "infix "
  540.              else ppsay "infixr ";
  541.              if i div 2 > 0 then
  542.                (ppsay(makestring(i div 2));
  543.             ppsay " ")
  544.              else ());
  545.        ppSequence ppstrm
  546.          {sep=(fn ppstrm => add_break ppstrm (1,0)),
  547.           pr=ppSym,style=INCONSISTENT}
  548.          ops;
  549.        end_block ppstrm)
  550.       | ppDec'(OVLDdec ovldvar,d) =
  551.       (ppsay "overload "; ppVar ppstrm ovldvar)
  552.       | ppDec'(OPENdec strVars,d) =
  553.       (begin_block ppstrm CONSISTENT 0;
  554.        ppsay "open ";
  555.        ppSequence ppstrm
  556.          {sep=(fn ppstrm => add_break ppstrm (1,0)),
  557.           pr=(fn ppstrm => fn STRvar{name,...} => ppSym ppstrm name),
  558.           style=INCONSISTENT}
  559.          strVars;
  560.        end_block ppstrm)
  561.       | ppDec'(MARKdec(dec,s,e),d) = 
  562.       (case source_opt
  563.         of SOME source =>
  564.            (ppsay "MARKdec(";
  565.         ppDec'(dec,d); ppsay ",";
  566.         prpos(ppstrm,source,s); ppsay ",";
  567.         prpos(ppstrm,source,e); ppsay ")")
  568.          | NONE => ppDec'(dec,d))
  569.    in ppDec'
  570.   end
  571.  
  572. and ppStrexp (context as (_,source_opt)) ppstrm =
  573.     let val ppsay = add_string ppstrm
  574.     fun ppStrexp'(_,0) = ppsay "<strexp>"
  575.       | ppStrexp'(VARstr(STRvar{access,name,...}),d) = ppSym ppstrm name
  576.       | ppStrexp'(STRUCTstr{body,...},d) =
  577.           (begin_block ppstrm CONSISTENT 0;
  578.            ppsay "struct"; nl_indent ppstrm 2;
  579.            ppSequence ppstrm
  580.          {sep=add_newline,
  581.           pr=(fn ppstrm => fn dec => ppDec context ppstrm (dec,d-1)),
  582.           style=CONSISTENT}
  583.          body;
  584.            ppsay "end";
  585.            end_block ppstrm)
  586.       | ppStrexp'(APPstr{oper=FCTvar{name,...}, argexp,...},d) =
  587.           (ppSym ppstrm name; ppsay"(";
  588.            ppStrexp'(argexp,d-1);
  589.            ppsay")")
  590.       | ppStrexp'(LETstr(dec,body),d) =
  591.           (begin_block ppstrm CONSISTENT 0;
  592.            ppsay "let "; ppDec context ppstrm (dec,d-1); add_newline ppstrm;
  593.            ppsay " in "; ppStrexp'(body,d-1); add_newline ppstrm;
  594.            ppsay "end";
  595.            end_block ppstrm)
  596.       | ppStrexp'(MARKstr(body,s,e),d) =
  597.           (case source_opt
  598.         of SOME source =>
  599.                (ppsay "MARKstr(";
  600.             ppStrexp'(body,d); ppsay ",";
  601.             prpos(ppstrm,source,s); ppsay ",";
  602.             prpos(ppstrm,source,e); ppsay ")")
  603.              | NONE => ppStrexp'(body,d))
  604.      in ppStrexp'
  605.     end
  606.  
  607. end (* structure PPAbsyn *)
  608.